home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / zsh-3.0-p / zsh-3 / zsh-3.0-pre3 / Misc / lete2ctl < prev    next >
Text File  |  1996-05-06  |  9KB  |  300 lines
  1. #!/usr/local/bin/perl -- -*-perl-*-
  2. #
  3. #   ``Wee have also Shelles, thee Lyke of whych you knowe not, wherein
  4. #     thee User may with thee merest Presse of thee Tabbe-Keye expande
  5. #     or compleat al Maner of Wordes and such-like Diversities.''
  6. #            - Francis Bacon, `New Atlantis' (or not).
  7. #
  8. # Convert tcsh "complete" statements to zsh "compctl" statements.
  9. # Runs as a filter.  Should ignore anything which isn't a "complete".
  10. # It expects each "complete" statement to be the first thing on a line.
  11. # All the examples in the tcsh manual give sensible results.
  12. # Author:  Peter Stephenson <pws@s-a.amtp.liv.ac.uk>
  13. #
  14. # Option:
  15. # -x (exact): only applies in the case of command disambiguation (is
  16. #    that really a word?)  If you have lines like
  17. #       complete '-co*' 'p/0/(compress)'
  18. #    (which makes co<TAB> always complete to `compress') then the
  19. #    resulting "compctl" statements will produce one of two behaviours:
  20. #    (1) By default (like tcsh), com<TAB> etc. will also complete to
  21. #        "compress" and nothing else.
  22. #    (2) With -x, com<TAB> does ordinary command completion: this is
  23. #        more flexible.
  24. #    I don't understand what the hyphen in complete does and I've ignored it.
  25. #
  26. # Notes:
  27. # (1) The -s option is the way to do backquote expansion.  In zsh,
  28. #     "compctl -s '`users`' talk" works (duplicates are removed).
  29. # (2) Complicated backquote completions should definitely be rewritten as
  30. #     shell functions (compctl's "-K func" option).  Although most of
  31. #     these will be translated correctly, differences in shell syntax
  32. #     are not handled.
  33. # (3) Replacement of $:n with the n'th word on the current line with
  34. #     backquote expansion now works; it is not necessarily the most
  35. #     efficient way of doing it in any given case, however.
  36. # (4) I have made use of zsh's more sophisticated globbing to change
  37. #     things like ^foo.{a,b,c,d} to ^foo.(a|b|c|d), which works better.
  38. #     It's just possible in some cases you may want to change it back.
  39. # (5) Make sure all command names with wildcards are processed together --
  40. #     they need to be lumped into one "compctl -C" or "compctl -D"
  41. #     statement for zsh.
  42.  
  43. # Handle options
  44. ($ARGV[0] eq '-x') && shift && ($opt_x = 1);
  45. ($ARGV[0] =~ /^-+$/) && shift;
  46.  
  47. # Function names used (via magic autoincrement) when cmdline words are needed
  48. $funcnam = 'compfn001';
  49.  
  50. # Read next word on command line
  51. sub getword {
  52.     local($word, $word2, $ret);
  53.     ($_) = /^\s*(.*)$/;
  54.     while ($_ =~ /^\S/) {
  55.     if (/^[\']/) {
  56.         ($word, $_) = /^\'([^\']*).(.*)$/;
  57.     } elsif (/^[\"]/) {
  58.         ($word, $_) = /^\"([^\"]*).(.*)$/;
  59.         while ($word =~ /\\$/) {
  60.         chop($word);
  61.         ($word2, $_) = /^([^\"]*).(.*)$/;
  62.         $word .= '"' . $word2;
  63.         }
  64.     } elsif (/\S/) {
  65.         ($word, $_) = /^([^\s\\\'\"#;]*)(.*)$/;
  66.         # Backslash: literal next character
  67.         /^\\(.)/ && (($word .= substr($_,1,1)),
  68.              ($_ = substr($_,2)));
  69.         # Rest of line quoted or end of command
  70.         /^[#;]/ && ($_ = '');
  71.     } else {
  72.         return undef;
  73.     }
  74.     length($word) && ($ret = $ret . $word);
  75.     }
  76.     $ret;
  77. }
  78.  
  79. # Interpret the x and arg in 'x/arg/type/'
  80. sub getpat {
  81.     local($pat,$arg) = @_;
  82.     local($ret,$i);
  83.     if ($pat eq 'p') {
  84.     $ret = "p[$arg]";
  85.     } elsif ($pat eq 'n' || $pat eq 'N') {
  86.     $let = ($arg =~ /[*?|]/) ? 'C' : 'c';
  87.     $num = ($pat eq 'N') ? 2 : 1;
  88.     $ret = "${let}[-${num},$arg]";
  89.     } elsif ($pat eq 'c' || $pat eq 'C') {
  90.     # A few tricks to get zsh to ignore up to the end of
  91.     # any matched pattern.
  92.     if (($pat eq 'c' && $arg =~ /^\*([^*?]*)$/)) {
  93.         $ret = "n[-1,$1]";
  94.     } elsif ($arg =~ /[*?]([^*?]*)$/) {
  95.         length($1) && ($ret = " n[-1,$1]");
  96.         $ret = "C[0,$arg] $ret";
  97.     } else {
  98.         $let = ($pat eq 'c') ? 's' : 'S';
  99.         $ret = "${let}[$arg]";
  100.     }
  101.     }
  102.     $ret =~ s/'/'\\''/g;
  103.     $ret;
  104. }
  105.  
  106. # Interpret the type in 'x/arg/type/'
  107. sub gettype {
  108.     local ($_) = @_;
  109.     local($qual,$c,$glob,$ret,$b,$m,$e,@m);
  110.     $c = substr($_,0,1);
  111.     ($c =~ /\w/) && (substr($_,1,1) eq ':') && ($glob = substr($_,2));
  112. # Nothing (n) can be handled by returning nothing.  (C.f. King Lear, I.i.)
  113.     if ($c =~ /[abcjuv]/) {
  114.     $ret = "-$c";
  115.     } elsif ($c eq 'S') {
  116.     $ret = '-k signals';
  117.     } elsif ($c eq 'd') {
  118.     $qual = '/';
  119.     } elsif ($c eq 'e') {
  120.     $ret = '-E';
  121.     } elsif ($c eq 'f' && !$glob) {
  122.     $ret = '-f';
  123.     } elsif ($c eq 'l') {
  124.     $ret = qq
  125. -k  '(cputime filesize datasize stacksize coredumpsize resident descriptors)'
  126.     ;
  127.     } elsif ($c eq 'p') {
  128.     # Use globbing, but make sure there's a star at the end
  129.     ($glob =~ /\*$/) || ($glob .= '*');
  130.     } elsif ($c eq 's') {
  131.     $ret = '-p';
  132.     } elsif ($c eq 't') {
  133.     $qual = '.';
  134.     } elsif ($c eq 'x') {
  135.     $glob =~ s/'/'\\''/g;
  136.     $ret = "-X '$glob'";
  137.     undef($glob);
  138.     } elsif ($c eq '$') {     # '{
  139.     $ret = "-k " . substr($_,1);
  140.     } elsif ($c eq '(') {
  141.     s/'/'\\''/g;
  142.     $ret = "-k '$_'";
  143.     } elsif ($c eq '`') {
  144.     # this took some working out...
  145.     if (s/\$:(\d+)/$foo=$1+1,"\${word[$foo]}"/ge) {
  146.         $ret = "-K $funcnam";
  147.         $genfunc .= <<"HERE";
  148. function $funcnam {
  149.     local word
  150.     read -cA word
  151.     reply=($_)
  152. }
  153. HERE
  154.         $funcnam++;
  155.     } else {
  156.         s/'/'\\''/g;
  157.         $ret = "-s '$_'";
  158.     }
  159.     }
  160.  
  161.     # foo{bar,ba,blak,sheap} -> foo(bar|ba|blak|sheap).
  162.     # This saves a lot of mess, since in zsh brace expansion occurs
  163.     # before globbing.  I'm sorry, but I don't trust $` and $'.
  164.     while ((($b,$m,$e) = ($glob =~ /^(.*)\{(.*)\}(.*)$/))
  165.        && ($m =~ /,/)) {
  166.     @m = split(/,/, $m);
  167.     for ($i = 0; $i < @m; $i++) {
  168.         while ($m[$i] =~ /\\$/) {
  169.         substr($m[$i],-1,1) = "";
  170.         splice(@m,$i,2,"$m[$i]\\,$m[$i+1]");
  171.         }
  172.     }
  173.     $glob = $b . "(" . join('|',@m) . ")" . $e;
  174.     }
  175.  
  176.     if ($qual) {
  177.     $glob || ($glob = '*');
  178.     $glob .= "($qual)";
  179.     }
  180.     $glob && (($glob =~ s/'/'\\''/g),($glob = "-g '$glob'"));
  181.  
  182.     defined($ret) && defined($glob) && ($ret .= " $glob");
  183.     defined($ret) ? $ret : $glob;
  184. }
  185.  
  186. # Quoted array separator for extended completions
  187. $" = " - ";
  188.  
  189. while (<>) {
  190.     if (/^\s*complete\s/) {
  191.     $wc = 0;
  192.     undef(@stuff); undef($default);
  193.     $_ = $';
  194.     while (/\\$/) {
  195.         # Remove backslashed newlines: in principle these should become
  196.         # real newlines inside quotes, but what the hell.
  197.         ($_) = /^(.*)\\$/;
  198.         $_ .= <>;
  199.     }
  200.     $command = &getword;
  201.     if ($command =~ /^-/ || $command =~ /[*?]/) {
  202.         # E.g. complete -co* ...
  203.         $defmatch = $command;
  204.         ($defmatch =~ /^-/) && ($defmatch = substr($defmatch,1));
  205.     } else {
  206.         undef($defmatch);
  207.     }
  208.     while (defined($word = &getword)) {
  209.         # Loop over remaining arguments to "complete".
  210.         $sep = substr($word,1,1);
  211.         $sep =~ s/(\W)/\\$1/g;
  212.         @split = split(/$sep/,$word);
  213.         for ($i = 0; $i < 3; $i++) {
  214.         while ($split[i] =~ /\\$/) {
  215.             substr($split[i],-1,1) = "";
  216.             splice(@split,$i,2,"$split[i]\\$sep$split[i+1]");
  217.         }
  218.         }
  219.         ($pat,$arg,$type,$suffix,$crap) = @split;
  220.         ($suffix =~ /^\s*$/) && undef($suffix);
  221.         if (($word =~ /^n${sep}\*${sep}/) &&
  222.          (!defined($defmatch))) {
  223.          # The "complete" catch-all:  treat this as compctl\'s
  224.          # default (requiring no pattern matching).
  225.         $default .= &gettype($type) . ' ';
  226.         defined($suffix) && ($defsuf .= $suffix);
  227.         } else {
  228.         $pat = &getpat($pat,$arg);
  229.         $type = &gettype($type);
  230.         if (defined($defmatch)) {
  231.             # The command is a pattern: use either -C or -D option.
  232.             if ($pat eq 'p[0]') {
  233.             # Command word (-C): 'p[0]' is redundant.
  234.             if ($defmatch eq '*') {
  235.                 $defcommand = $type;
  236.             } else {
  237.                 ($defmatch =~ /\*$/) && chop($defmatch);
  238.                 if ($opt_x) {
  239.                 $c = ($defmatch =~ /[*?]/) ? 'C' : c;
  240.                 $pat = "${c}[0,${defmatch}]";
  241.                 } else {
  242.                 $pat = ($defmatch =~ /[*?]/) ?
  243.                     "C[0,${defmatch}]" : "S[${defmatch}]";
  244.                 }
  245.                 push(@commandword,defined($suffix) ?
  246.                  "'$pat' $type -S '$suffix'" : "'$pat' $type");
  247.             }
  248.             } elsif ($pat eq "C[-1,*]") {
  249.             # Not command word completion, but match
  250.             # command word (only)
  251.             if ($defmatch eq "*") {
  252.                 # any word of any command
  253.                 $defaultdefault .= " $type";
  254.             } else {
  255.                 $pat = "W[0,$defmatch]";
  256.                 push(@defaultword,defined($suffix) ?
  257.                  "'$pat' $type -S '$suffix'" : "'$pat' $type");
  258.             }
  259.             } else {
  260.                 # Not command word completion, but still command
  261.             # word with pattern
  262.             ($defmatch = '*') || ($pat = "W[0,$defmatch] $pat");
  263.             push(@defaultword,defined($suffix) ?
  264.                  "'$pat' $type -S '$suffix'" : "'$pat' $type");
  265.             }
  266.         } else {
  267.             # Ordinary command
  268.             push(@stuff,defined($suffix) ?
  269.              "'$pat' $type -S '$suffix'" : "'$pat' $type");
  270.         }
  271.         }
  272.     }
  273.         if (!defined($defmatch)) {
  274.         # Ordinary commands with no pattern
  275.         print("compctl $default");
  276.         defined($defsuf) && print("-S '$defsuf' ") && undef($defsuf);
  277.         defined(@stuff) && print("-x @stuff -- ");
  278.         print("$command\n");
  279.     }
  280.     if (defined($genfunc)) {
  281.         print $genfunc;
  282.         undef($genfunc);
  283.     }
  284.     }
  285. }
  286.  
  287. (defined(@commandword) || defined($defcommand)) &&
  288.     print("compctl -C ",
  289.       defined($defcommand) ? $defcommand : '-c',
  290.       defined(@commandword) ? " -x @commandword\n" : "\n");
  291.  
  292. if (defined($defaultdefault) || defined(@defaultword)) {
  293.     defined($defaultdefault) || ($defaultdefault = "-f");
  294.     print "compctl -D $defaultdefault";
  295.     defined(@defaultword) && print(" -x @defaultword");
  296.     print "\n";
  297. }
  298.  
  299. __END__
  300.